home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-thread.el.z / vm-thread.el
Encoding:
Text File  |  1998-05-21  |  10.5 KB  |  295 lines
  1. ;;; Thread support for VM
  2. ;;; Copyright (C) 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-thread)
  19.  
  20. (defun vm-toggle-threads-display ()
  21.   "Toggle the threads display on and off.
  22. When the threads display is on, the folder will be sorted by
  23. thread and thread indentation (via the %I summary format specifier)
  24. will be visible."
  25.   (interactive)
  26.   (vm-select-folder-buffer)
  27.   (vm-check-for-killed-summary)
  28.   (vm-set-summary-redo-start-point t)
  29.   (setq vm-summary-show-threads (not vm-summary-show-threads))
  30.   (if vm-summary-show-threads
  31.       (vm-sort-messages "thread")
  32.     (vm-sort-messages "physical-order")))
  33.  
  34. (defun vm-build-threads (message-list)
  35.   (if (null vm-thread-obarray)
  36.       (setq vm-thread-obarray (make-vector 641 0)
  37.         vm-thread-subject-obarray (make-vector 641 0)))
  38.   (let ((mp (or message-list vm-message-list))
  39.     (n 0)
  40.     ;; Just for laughs, make the update interval vary.
  41.     (modulus (+ (% (vm-abs (random)) 11) 40))
  42.     ;; no need to schedule reindents of reparented messages
  43.     ;; unless there were already messages present.
  44.     (schedule-reindents message-list)
  45.     m parent parent-sym id id-sym date refs old-parent-sym)
  46.     (while mp
  47.       (setq m (car mp)
  48.         parent (vm-th-parent m)
  49.         id (vm-su-message-id m)
  50.         id-sym (intern id vm-thread-obarray)
  51.         date (vm-so-sortable-datestring m))
  52.       (put id-sym 'messages (cons m (get id-sym 'messages)))
  53.       (if (and (null (cdr (get id-sym 'messages)))
  54.            schedule-reindents)
  55.       (vm-thread-mark-for-summary-update (get id-sym 'children)))
  56.       (if parent
  57.       (progn
  58.         (setq parent-sym (intern parent vm-thread-obarray))
  59.         (cond ((or (not (boundp id-sym))
  60.                (null (symbol-value id-sym))
  61.                (eq (symbol-value id-sym) parent-sym))
  62.            (set id-sym parent-sym))
  63.           (t
  64.            (setq old-parent-sym (symbol-value id-sym))
  65.            (put old-parent-sym 'children
  66.             (let ((kids (get old-parent-sym 'children))
  67.                   (msgs (get id-sym 'messages)))
  68.               (while msgs
  69.                 (setq kids (delq m kids)
  70.                   msgs (cdr msgs)))
  71.               kids ))
  72.            (set id-sym parent-sym)
  73.            (if schedule-reindents
  74.                (vm-thread-mark-for-summary-update
  75.             (get id-sym 'messages)))))
  76.         (put parent-sym 'children
  77.          (cons m (get parent-sym 'children))))
  78.     (if (not (boundp id-sym))
  79.         (set id-sym nil)))
  80.       ;; use the references header to set parenting information
  81.       ;; for ancestors of this message.  This does not override
  82.       ;; a parent pointer for a message if it already exists.
  83.       (if (cdr (setq refs (vm-th-references m)))
  84.       (let (parent-sym id-sym msgs)
  85.         (setq parent-sym (intern (car refs) vm-thread-obarray)
  86.           refs (cdr refs))
  87.         (while refs
  88.           (setq id-sym (intern (car refs) vm-thread-obarray))
  89.           (if (and (boundp id-sym) (symbol-value id-sym))
  90.           nil
  91.         (set id-sym parent-sym)
  92.         (if (setq msgs (get id-sym 'messages))
  93.             (put parent-sym 'children
  94.              (append msgs (get parent-sym 'children))))
  95.         (if schedule-reindents
  96.             (vm-thread-mark-for-summary-update msgs)))
  97.           (setq parent-sym id-sym
  98.             refs (cdr refs)))))
  99.       (if vm-thread-using-subject
  100.       ;; inhibit-quit because we need to make sure the asets
  101.       ;; below are an atomic group.
  102.       (let* ((inhibit-quit t)
  103.          (subject (vm-so-sortable-subject m))
  104.          (subject-sym (intern subject vm-thread-subject-obarray)))
  105.         ;; if this subject never seen before create the
  106.         ;; information vector.
  107.         (if (not (boundp subject-sym))
  108.         (set subject-sym
  109.              (vector id-sym (vm-so-sortable-datestring m)
  110.                  nil (list m)))
  111.           ;; this subject seen before 
  112.           (aset (symbol-value subject-sym) 3
  113.             (cons m (aref (symbol-value subject-sym) 3)))
  114.           (if (string< date (aref (symbol-value subject-sym) 1))
  115.           (let* ((vect (symbol-value subject-sym))
  116.              (i-sym (aref vect 0)))
  117.             ;; optimization: if we know that this message
  118.             ;; already has a parent, then don't bother
  119.             ;; adding it to the list of child messages
  120.             ;; since we know that it will be threaded and
  121.             ;; unthreaded using the parent information.
  122.             (if (or (not (boundp i-sym))
  123.                 (null (symbol-value i-sym)))
  124.             (aset vect 2 (append (get i-sym 'messages)
  125.                          (aref vect 2))))
  126.             (aset vect 0 id-sym)
  127.             (aset vect 1 date)
  128.             ;; this loops _and_ recurses and I'm worried
  129.             ;; about it going into a spin someday.  So I
  130.             ;; unblock interrupts here.  It's not critical
  131.             ;; that it finish... the summary will just be out
  132.             ;; of sync.
  133.             (if schedule-reindents
  134.             (let ((inhibit-quit nil))
  135.               (vm-thread-mark-for-summary-update (aref vect 2)))))
  136.         ;; optimization: if we know that this message
  137.         ;; already has a parent, then don't bother adding
  138.         ;; it to the list of child messages, since we
  139.         ;; know that it will be threaded and unthreaded
  140.         ;; using the parent information.
  141.         (if (null parent)
  142.             (aset (symbol-value subject-sym) 2
  143.               (cons m (aref (symbol-value subject-sym) 2))))))))
  144.       (setq mp (cdr mp) n (1+ n))
  145.       (if (zerop (% n modulus))
  146.       (message "Building threads... %d" n)))
  147.     (if (> n modulus)
  148.     (message "Building threads... done"))))
  149.  
  150. (defun vm-thread-mark-for-summary-update (message-list)
  151.   (let (m)
  152.     (while message-list
  153.       (setq m (car message-list))
  154.       ;; if thread-list is null then we've already marked this
  155.       ;; message, or it doesn't need marking.
  156.       (if (null (vm-thread-list-of m))
  157.       nil
  158.     (vm-mark-for-summary-update m t)
  159.     (vm-set-thread-list-of m nil)
  160.     (vm-set-thread-indentation-of m nil)
  161.     (vm-thread-mark-for-summary-update
  162.      (get (intern (vm-su-message-id m) vm-thread-obarray)
  163.           'children)))
  164.       (setq message-list (cdr message-list)))))
  165.  
  166. (defun vm-thread-list (message)
  167.   (let ((done nil)
  168.     (m message)
  169.     thread-list id-sym subject-sym loop-sym root-date)
  170.     (save-excursion
  171.       (set-buffer (vm-buffer-of m))
  172.       (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
  173.         thread-list (list id-sym))
  174.       (fillarray vm-thread-loop-obarray 0)
  175.       (while (not done)
  176.     (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
  177.     (if (boundp loop-sym)
  178.         ;; loop detected, bail...
  179.         (setq done t)
  180.       (set loop-sym t)
  181.       (if (and (boundp id-sym) (symbol-value id-sym))
  182.           (progn
  183.         (setq id-sym (symbol-value id-sym)
  184.               thread-list (cons id-sym thread-list)
  185.               m (car (get id-sym 'messages))))
  186.         (if (null m)
  187.         (setq done t)
  188.           (if (null vm-thread-using-subject)
  189.           nil
  190.         (setq subject-sym
  191.               (intern (vm-so-sortable-subject m)
  192.                   vm-thread-subject-obarray))
  193.         (if (or (not (boundp subject-sym))
  194.             (eq (aref (symbol-value subject-sym) 0) id-sym))
  195.             (setq done t)
  196.           (setq id-sym (aref (symbol-value subject-sym) 0)
  197.             thread-list (cons id-sym thread-list)
  198.             m (car (get id-sym 'messages)))))))))
  199.       ;; save the date of the oldest message in this thread
  200.       (setq root-date (get id-sym 'oldest-date))
  201.       (if (or (null root-date)
  202.           (string< (vm-so-sortable-datestring message) root-date))
  203.       (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
  204.       thread-list )))
  205.  
  206. ;; remove message struct from thread data.
  207. ;;
  208. ;; optional second arg non-nil means forget information that
  209. ;; might be different if the message contents changed.
  210. ;;
  211. ;; message must be a real (non-virtual) message
  212. (defun vm-unthread-message (message &optional message-changing)
  213.   (save-excursion
  214.     (let ((mp (cons message (vm-virtual-messages-of message)))
  215.       m id-sym subject-sym vect p-sym)
  216.       (while mp
  217.     (setq m (car mp))
  218.     (let ((inhibit-quit t))
  219.       (vm-set-thread-list-of m nil)
  220.       (vm-set-thread-indentation-of m nil)
  221.       (set-buffer (vm-buffer-of m))
  222.       (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
  223.         subject-sym (intern (vm-so-sortable-subject m)
  224.                     vm-thread-subject-obarray))
  225.       (if (boundp id-sym)
  226.           (progn
  227.         (put id-sym 'messages (delq m (get id-sym 'messages)))
  228.         (vm-thread-mark-for-summary-update (get id-sym 'children))
  229.         (setq p-sym (symbol-value id-sym))
  230.         (and p-sym (put p-sym 'children
  231.                 (delq m (get p-sym 'children))))
  232.         (if message-changing
  233.             (set id-sym nil))))
  234.       (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
  235.           (if (not (eq id-sym (aref vect 0)))
  236.           (aset vect 2 (delq m (aref vect 2)))
  237.         (if message-changing
  238.             (if (null (cdr (aref vect 3)))
  239.             (makunbound subject-sym)
  240.               (let ((p (aref vect 3))
  241.                 oldest-msg oldest-date children)
  242.             (setq oldest-msg (car p)
  243.                   oldest-date (vm-so-sortable-datestring (car p))
  244.                   p (cdr p))
  245.             (while p
  246.               (if (and (string-lessp (vm-so-sortable-datestring (car p))
  247.                          oldest-date)
  248.                    (not (eq m (car p))))
  249.                   (setq oldest-msg (car p)
  250.                     oldest-date (vm-so-sortable-datestring (car p))))
  251.               (setq p (cdr p)))
  252.             (aset vect 0 (intern (vm-su-message-id oldest-msg)
  253.                          vm-thread-obarray))
  254.             (aset vect 1 oldest-date)
  255.             (setq children (delq oldest-msg (aref vect 2)))
  256.             (aset vect 2 children)
  257.             (aset vect 3 (delq m (aref vect 3)))
  258.             ;; I'm not sure there aren't situations
  259.             ;; where this might loop forever.
  260.             (let ((inhibit-quit nil))
  261.               (vm-thread-mark-for-summary-update children))))))))
  262.       (setq mp (cdr mp))))))
  263.  
  264. (defun vm-th-references (m)
  265.   (or (vm-references-of m)
  266.       (vm-set-references-of
  267.        m
  268.        (let (references)
  269.      (setq references (vm-get-header-contents m "References:" " "))
  270.      (and references (vm-parse references "[^<]*\\(<[^>]+>\\)"))))))
  271.  
  272. (defun vm-th-parent (m)
  273.   (or (vm-parent-of m)
  274.       (vm-set-parent-of
  275.        m
  276.        (or (car (vm-last (vm-th-references m)))
  277.        (let (in-reply-to)
  278.          (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " "))
  279.          (and in-reply-to
  280.           (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
  281.  
  282. (defun vm-th-thread-indentation (m)
  283.   (or (vm-thread-indentation-of m)
  284.       (let ((p (vm-th-thread-list m)))
  285.     (while (and p (null (get (car p) 'messages)))
  286.       (setq p (cdr p)))
  287.     (vm-set-thread-indentation-of m (1- (length p)))
  288.     (vm-thread-indentation-of m))))
  289.  
  290. (defun vm-th-thread-list (m)
  291.   (or (vm-thread-list-of m)
  292.       (progn
  293.     (vm-set-thread-list-of m (vm-thread-list m))
  294.     (vm-thread-list-of m))))
  295.